COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(setq d
C00006 ENDMK
C⊗;
(setq d
      '(DO ((BL LL (CDR BL))
	    (N 0 (COND ((EQUAL 'T (CAR BL))
			(1+ N))
		       (T N)))
	    (S 0 (COND ((EQ 'T (CAR BL))
			(STORE (BR N) (+ S 3))
			0)
		       (T (+ S 3)))))
	   ((NULL BL) (PRINT (LIST N S)))
	   (PRINT (LIST N S))))

(DEFUN QNILP (X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (NULL (CADR X))))

(COMMENT P1DO)

(DEFUN P1DO (XX)
    (PROG (INDXL ENDTST ENDVAL TG1 TAG3 PVARS LVARS STEPDVARS LVALS BODY DECL X)
	  (SETQ X (CDR XX))
	  (COND ((AND (CAR X) (ATOM (CAR X)))
		 (SETQ  INDXL (LIST (LIST (POP X) (POP X) (POP X)))
			ENDTST (POP X) 
			ENDVAL ()
			TG1 (LIST (GENSYM))))
		('T (SETQ INDXL (REVERSE (POP X))) 
		    (COND ((SETQ ENDTST (POP X))
			   (SETQ ENDVAL (COND ((OR (NULL (CDR ENDTST))
						   (NULL (CADR ENDTST))
						   (AND (NOT (ATOM (CADR ENDTST)))
							(QNILP (CADR ENDTST))))
					       () )
					      ('T (REVERSE (CDR ENDTST))))
				 ENDTST (CAR ENDTST)
				 TG1 (LIST (GENSYM))))
			  ('T (SETQ ENDTST CLPROGN)))))
	  (MAPC '(LAMBDA (X) (COND ((COND ((ATOM X))
					  ((NULL (CDR X)) (SETQ X (CAR X)) 'T)) 
				    (PUSH X PVARS))
				   ('T (PUSH (CAR X) LVARS)  
				       (PUSH (CADR X) LVALS)
				       (AND (CDDR X) (PUSH X STEPDVARS))
				       (AND (CDDDR X) (SETQ XX () ))
				       (SETQ X (CAR X))))
			     (AND (NOT (SYMBOLP X)) (SETQ XX () )))
		INDXL)
	  (AND (NULL XX) (RETURN () ))
	  (AND (NOT (ATOM (CAR X))) 
	       (EQ (CAAR X) 'DECLARE)
	       (POP X DECL))
	  (SETQ BODY (LIST 
			(NCONC  (LIST 'PROG PVARS)
				TG1 
				(AND (AND TG1 ENDTST)
				     (OR (ATOM ENDTST) (NOT (QNILP ENDTST)))
				     (LIST 
				      (LIST 
					'COND
					(CONS ENDTST 
					      (COND ((NULL ENDVAL) '((RETURN () )))
						    (TAG3 (LIST (LIST 'GO TAG3)))
						    ('T (P1DO-RETURN ENDVAL)))))))
				(APPEND X () )
				(AND STEPDVARS (LIST (P1DO-STEPPER STEPDVARS)))
				(LIST (COND (TG1 (LIST 'GO (CAR TG1)))
					    ((EQ ENDTST CLPROGN) '(RETURN () ))
					    ((DBARF XX |Bad DO format|)) ))
				(AND TAG3 (CONS TAG3 (P1DO-RETURN ENDVAL))))))
	  (AND DECL (SETQ BODY (CONS DECL BODY)))
	  (RETURN (CONS (CONS 'LAMBDA (CONS LVARS BODY)) LVALS))))


(DEFUN P1DO-RETURN (ENDVAL) 
    (NREVERSE (CONS (LIST 'RETURN (CAR ENDVAL)) (CDR ENDVAL))))

(DEFUN P1DO-STEPPER (L) 
    (LIST 'SETQ 
	  (CAAR L)
	  (COND  ((NULL (CDR L)) (CADDAR L))
		 ((LIST 'PROG2 () (CADDAR L) (P1DO-STEPPER (CDR L)))))))